home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1994 / MacHack 1994.toast / MacHack™ 1987-1994 / MacHack™ '92 / Talk & Papers ’92 / Mike Engber (LISP) / font-menus.Lisp < prev    next >
Lisp/Scheme  |  1992-06-11  |  9KB  |  237 lines
  1. ;;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;font-menus.lisp
  4. ;;copyright © 1988-1991 Apple Computer, Inc.
  5. ;;
  6. ;;
  7. ;;  this file defines a set of hierarchical menus which can be used for
  8. ;;  setting the font of the current window.
  9. ;;
  10. ;;
  11.  
  12. (in-package :ccl)
  13.  
  14. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15. ;;
  16. ;; Mod History
  17. ;;
  18. ;; 03/10/92 bill Doug Currie's enable-font-menus
  19. ;; 02/28/92 gb   remove redundant when from menu-item-action
  20. ;; ------------- 2.0f3
  21. ;; 10/16/91 bill eliminate consing at menu-update time.
  22. ;; 09/19/91 bill replace slot-value with accessors
  23. ;; 09/08/91 wkf  Prevent unneccessary consing and speed up menu-item-update.
  24. ;; 06/25/91 bill The *font-menu* is updated at startup.
  25. ;; 06/13/91 bill WKF's fix for menu-item-update when no windows are open.
  26. ;; 04/03/91 bill Prevent error in menu-item-update when there are no windows
  27. ;;
  28.  
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30. ;;
  31. ;;  define a font-menu class and some methods.
  32. ;;
  33.  
  34. (defclass font-menu (menu)
  35.   ((selection-font :initform (cons 0 0) :accessor selection-font)))
  36.  
  37. (defgeneric enable-font-menus-p (view)
  38.   (:method ((v fred-mixin)) t)
  39.   (:method ((v basic-editable-text-dialog-item)) t)
  40.   (:method ((v t)) nil))
  41.  
  42. (defmethod menu-update ((self font-menu))
  43.   (let* ((w (front-window))
  44.          (key-handler (and w  (or (current-key-handler w) w)))
  45.          (selection-font (selection-font self))
  46.          (ff 0) (ms 0))
  47.     (if (enable-font-menus-p key-handler)
  48.       (progn
  49.         (menu-item-enable self)
  50.         (multiple-value-setq (ff ms) (view-font-codes key-handler)))
  51.       (menu-item-disable self))
  52.     (setf (car selection-font) ff (cdr selection-font) ms))
  53.   (call-next-method))
  54.  
  55.  
  56. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  57. ;;
  58. ;;  define some variables for holding the menus
  59. ;;
  60.  
  61. (defvar *font-menu*       (make-instance 'font-menu :menu-title "Font")) ;  9-Aug-91 -wkf
  62. (defvar *font-size-menu*  (make-instance 'font-menu :menu-title "Font Size")) ;  9-Aug-91 -wkf
  63. (defvar *font-style-menu* (make-instance 'font-menu :menu-title "Font Style")) ;  9-Aug-91 -wkf
  64.  
  65. ; In case this file is loaded more than once.
  66. (apply 'remove-menu-items *font-menu* (menu-items *font-menu*))
  67. (apply 'remove-menu-items *font-size-menu* (menu-items *font-size-menu*))
  68. (apply 'remove-menu-items *font-style-menu* (menu-items *font-style-menu*))
  69.  
  70. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  71. ;;
  72. ;;  create a new class of menu-items for setting font attribute.
  73. ;;
  74. ;;  each menu-item has a title, and an attribute.  When the item is
  75. ;;  selected, it asks the top window to set-view-font to the attribute.
  76. ;;  In this way, there is only one action for the whole class.  (Each instance
  77. ;;  doesn't need its own action.  Each one just needs its own attribute).
  78. ;;
  79. ;;  The fact that the attribute is just like the name of the menu item
  80. ;;  is also convenient.
  81. ;;
  82.  
  83. (defclass font-menu-item (menu-item)
  84.   ((attribute :initarg :attribute
  85.               :reader attribute
  86.               :initform '("chicago" 12 :plain))))
  87.  
  88.  
  89. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  90. ;;
  91. ;;  arrange to put check marks by the current values of the font attributes,
  92. ;;  by asking the view what the font is and seeing if this attribute is present
  93. ;;  in addition, if this is a size attribute, see if the font is real
  94. ;;
  95.  
  96. (defmethod menu-item-update ((item font-menu-item))
  97.   ;; !!! Get selection font from menu which calculates it just once per update. 9-Aug-91 -wkf
  98.   (let* ((owner          (menu-item-owner item))
  99.          (selection-font (selection-font owner))
  100.          (attribute      (attribute item))
  101.          (ff             (car selection-font))
  102.          (ms             (cdr selection-font))
  103.          (fontp          (integerp ff)))
  104.     (set-menu-item-check-mark 
  105.      item
  106.      (and fontp
  107.           (cond ((stringp attribute)
  108.                  (let ((aff (font-codes attribute)))
  109.                    (eql (point-v aff) (point-v ff))))
  110.                 ((integerp attribute)
  111.                  (eql attribute (point-h ms)))
  112.                 (t (let* ((cell (assq attribute *style-alist*))
  113.                           (value (cdr cell))
  114.                           (face-code (lsh (point-h ff) -8)))
  115.                      (and value
  116.                           (if (eql 0 value)
  117.                             (eql 0 face-code)
  118.                             (not (eql 0 (logand face-code value))))))))))
  119.     (when (integerp attribute)          ; if it's a size attribute
  120.         (set-menu-item-style 
  121.          item
  122.          (if (and fontp (#_RealFont (point-v ff) (point-h ms)))
  123.            :outline
  124.            :plain)))))
  125.  
  126. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  127. ;;
  128. ;;  the menu-item-action asks the front window to set its view-font
  129. ;;  to the menu-item's attribute.
  130. ;;
  131.  
  132. (defmethod menu-item-action ((item font-menu-item))
  133.   (let ((w (front-window)))
  134.     (when w
  135.       (set-view-font (or (current-key-handler w) w) (attribute item)))))
  136.  
  137. ;;font-menus.Lisp
  138. ;;mod for changing insertion font after a select all
  139. #| 
  140. ;;original version
  141. (defmethod menu-item-action ((item font-menu-item))
  142.   (let ((w (front-window)))
  143.     (when w
  144.       (set-view-font (or (current-key-handler w) w) (attribute item)))))
  145. |#
  146.  
  147. ;;new version checks if we're change a fred window with everything selected
  148. ;; if so, it changes the insertion font. As an unwanted side effect it clears
  149. ;; the current selection - I don't know another way to set the insertion font.
  150. (defmethod menu-item-action ((item font-menu-item))
  151.   (let ((w (front-window)))
  152.     (when w
  153.       (let ((target (or (current-key-handler w) w)))
  154.         (set-view-font target (attribute item))
  155.         (when (subtypep (type-of target) 'fred-window)
  156.           (buffer-remove-unused-fonts (fred-buffer target))
  157.           (multiple-value-bind (start end) (selection-range w)
  158.             (when (and (zerop start) (= end (buffer-size (fred-buffer (or (current-key-handler w) w)))))
  159.               (set-selection-range target)
  160.               (set-view-font target (attribute item)))))))))
  161.  
  162. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  163. ;;
  164. ;;  here we set up the font menu.  We make an item for each font listed
  165. ;;  in the global variable *font-list*.  In this case, the menu-item name
  166. ;;  and the attribute are exactly the same (a string giving the name of a
  167. ;;  font).
  168. ;;
  169. ;;  We process the *font-list* to remove fonts that begin with a "%",
  170. ;;  because these aren't meant to be displayed in font menus.
  171. ;;
  172.  
  173. (defun add-font-menus ()
  174.   (apply #'remove-menu-items *font-menu* (menu-items *font-menu*))
  175.   (dolist (font-name (remove #\% *font-list*
  176.                              :key #'(lambda (string)
  177.                                       (elt string 0))))
  178.     (add-menu-items *font-menu* (make-instance 'font-menu-item
  179.                                   :menu-item-title font-name
  180.                                   :attribute font-name))))
  181.  
  182. (pushnew 'add-font-menus *lisp-startup-functions*)
  183. (add-font-menus)
  184.  
  185. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  186. ;;
  187. ;;  here we set up the font size menu.  Each menu-item has a number
  188. ;;  for its attribute.  To get the name of the menu-item, we just print
  189. ;;  the number into a string using the function FORMAT.
  190. ;;
  191.  
  192.  
  193. (dolist (font-size '(9 10 12 14 18 24))
  194.   (add-menu-items *font-size-menu*
  195.                   (make-instance 'font-menu-item
  196.                                  :menu-item-title (format nil "~d" font-size)
  197.                                  :attribute font-size)))
  198.  
  199.  
  200. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  201. ;;
  202. ;;  here we set up the font style menu.  In this case it's easiest to just
  203. ;;  give the attribute explicitly.
  204. ;;
  205. ;;  Once the menu-items are set up, we ask them to change their font style,
  206. ;;  so that they are displayed in the style they represent.
  207. ;;
  208.  
  209.  
  210. (add-menu-items
  211.  *font-style-menu*
  212.  (make-instance 'font-menu-item :menu-item-title "Plain" :attribute :plain)
  213.  (make-instance 'font-menu-item :menu-item-title "Bold" :attribute :bold)
  214.  (make-instance 'font-menu-item :menu-item-title "Italic" :attribute :italic)
  215.  (make-instance 'font-menu-item :menu-item-title "Underline" :attribute :underline)
  216.  (make-instance 'font-menu-item :menu-item-title "Outline" :attribute :outline)
  217.  (make-instance 'font-menu-item :menu-item-title "Shadow" :attribute :shadow)
  218.  (make-instance 'font-menu-item :menu-item-title "Condense" :attribute :condense)
  219.  (make-instance 'font-menu-item :menu-item-title "Extend" :attribute :extend))
  220. (dolist (menu-item (menu-items *font-style-menu*))
  221.   (set-menu-item-style menu-item (attribute menu-item)))
  222.  
  223.  
  224. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  225. ;;
  226. ;;  now that we have all the menus, we just add them to the *edit-menu*
  227. ;;  (preceded by a blank-line menu-item).
  228. ;;
  229.  
  230. (unless (find-menu-item *edit-menu* (menu-item-title *font-menu*))
  231.   (add-menu-items *edit-menu*
  232.                   (make-instance 'menu-item :menu-item-title "-")   ;a blank line
  233.                   *font-menu* *font-size-menu* *font-style-menu*))
  234.  
  235.  
  236.  
  237.